home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1995 January / Simtel - 10000 MSDOS Shareware Programs (Walnut Creek)(January 1995)(Disc 1).ISO / starter / uudecode.pas < prev    next >
Pascal/Delphi Source File  |  1986-12-12  |  6KB  |  225 lines

  1. program uudecode;
  2.  
  3.   CONST defaultSuffix = '.uue';
  4.         offset = 32;
  5.  
  6.   TYPE string80 = string[80];
  7.  
  8.   VAR infile: text;
  9.       fi    : file of byte;
  10.       outfile: file of byte;
  11.       lineNum: integer;
  12.       line: string80;
  13.       size,remaining :real;
  14.  
  15.   procedure Abort(message: string80);
  16.  
  17.     begin {abort}
  18.       writeln;
  19.       if lineNum > 0 then write('Line ', lineNum, ': ');
  20.       writeln(message);
  21.       halt
  22.     end; {Abort}
  23.  
  24.   procedure NextLine(var s: string80);
  25.  
  26.     begin {NextLine}
  27.       LineNum := succ(LineNum);
  28.       {write('.');}
  29.       readln(infile, s);
  30.       remaining:=remaining-length(s)-2;  {-2 is for CR/LF}
  31.       write('bytes remaining: ',remaining:7:0,' (',
  32.             remaining/size*100.0:3:0,'%)',chr(13));
  33.     end; {NextLine}
  34.  
  35.   procedure Init;
  36.  
  37.     procedure GetInFile;
  38.  
  39.       VAR infilename: string80;
  40.  
  41.       begin {GetInFile}
  42.         if ParamCount = 0 then abort ('Usage: uudecode <filename>');
  43.         infilename := ParamStr(1);
  44.         if pos('.', infilename) = 0
  45.           then infilename := concat(infilename, defaultSuffix);
  46.         assign(infile, infilename);
  47.         {$i-}
  48.         reset(infile);
  49.         {$i+}
  50.         if IOresult > 0 then abort (concat('Can''t open ', infilename));
  51.         writeln ('Decoding ', infilename);
  52.         assign(fi,infilename); reset(fi);
  53.         size:=FileSize(fi); close(fi);
  54.         if size < 0 then size:=size+65536.0;
  55.         remaining:=size;
  56.       end; {GetInFile}
  57.  
  58.     procedure GetOutFile;
  59.  
  60.       var header, mode, outfilename: string80;
  61.           ch: char;
  62.  
  63.       procedure ParseHeader;
  64.  
  65.         VAR index: integer;
  66.  
  67.         Procedure NextWord(var word:string80; var index: integer);
  68.  
  69.           begin {nextword}
  70.             word := '';
  71.             while header[index] = ' ' do
  72.               begin
  73.                 index := succ(index);
  74.                 if index > length(header) then abort ('Incomplete header')
  75.               end;
  76.             while header[index] <> ' ' do
  77.               begin
  78.                 word := concat(word, header[index]);
  79.                 index := succ(index)
  80.               end
  81.           end; {NextWord}
  82.  
  83.         begin {ParseHeader}
  84.           header := concat(header, ' ');
  85.           index := 7;
  86.           NextWord(mode, index);
  87.           NextWord(outfilename, index)
  88.         end; {ParseHeader}
  89.  
  90.       begin {GetOutFile}
  91.         if eof(infile) then abort('Nothing to decode.');
  92.         NextLine (header);
  93.         while not ((copy(header, 1, 6) = 'begin ') or eof(infile)) do
  94.           NextLine(header);
  95.         writeln;
  96.         if eof(infile) then abort('Nothing to decode.');
  97.         ParseHeader;
  98.         assign(outfile, outfilename);
  99.         writeln ('Destination is ', outfilename);
  100.         {$i-}
  101.         reset(outfile);
  102.         {$i+}
  103.         if IOresult = 0 then
  104.           begin
  105.             write ('Overwrite current ', outfilename, '? [Y/N] ');
  106.             repeat
  107.               read (kbd, ch);
  108.               ch := UpCase(ch)
  109.             until ch in ['Y', 'N'];
  110.             writeln(ch);
  111.             if ch = 'N' then abort ('Overwrite cancelled.')
  112.           end;
  113.         rewrite (outfile);
  114.       end; {GetOutFile}
  115.  
  116.     begin {init}
  117.       lineNum := 0;
  118.       GetInFile;
  119.       GetOutFile;
  120.     end; { init}
  121.  
  122.   Function CheckLine: boolean;
  123.  
  124.     begin {CheckLine}
  125.       if line = '' then abort ('Blank line in file');
  126.       CheckLine := not (line[1] in [' ', '`'])
  127.     end; {CheckLine}
  128.  
  129.  
  130.   procedure DecodeLine;
  131.  
  132.     VAR lineIndex, byteNum, count, i: integer;
  133.         chars: array [0..3] of byte;
  134.         hunk: array [0..2] of byte;
  135.  
  136. {    procedure debug;
  137.  
  138.       var i: integer;
  139.  
  140.       procedure writebin(x: byte);
  141.  
  142.         var i: integer;
  143.  
  144.         begin
  145.           for i := 1 to 8 do
  146.             begin
  147.               write ((x and $80) shr 7);
  148.               x := x shl 1
  149.             end;
  150.           write (' ')
  151.         end;
  152.  
  153.       begin
  154.         writeln;
  155.         for i := 0 to 3 do writebin(chars[i]);
  156.         writeln;
  157.         for i := 0 to 2 do writebin(hunk[i]);
  158.         writeln
  159.       end;      }
  160.  
  161.     function nextch: char;
  162.  
  163.       begin {nextch}
  164.         lineIndex := succ(lineIndex);
  165.         if lineIndex > length(line) then abort('Line too short.');
  166.         if not (line[lineindex] in [' '..'`'])
  167.           then abort('Illegal character in line.');
  168. {        write(line[lineindex]:2);}
  169.         if line[lineindex] = '`' then nextch := ' '
  170.                                  else nextch := line[lineIndex]
  171.       end; {nextch}
  172.  
  173.     procedure DecodeByte;
  174.  
  175.       procedure GetNextHunk;
  176.  
  177.         VAR i: integer;
  178.  
  179.         begin {GetNextHunk}
  180.           for i := 0 to 3 do chars[i] := ord(nextch) - offset;
  181.           hunk[0] := (chars[0] shl 2) + (chars[1] shr 4);
  182.           hunk[1] := (chars[1] shl 4) + (chars[2] shr 2);
  183.           hunk[2] := (chars[2] shl 6) + chars[3];
  184.           byteNum := 0  {;
  185.           debug          }
  186.         end; {GetNextHunk}
  187.  
  188.       begin {DecodeByte}
  189.         if byteNum = 3 then GetNextHunk;
  190.         write (outfile, hunk[byteNum]);
  191.         {writeln(bytenum, ' ', hunk[byteNum]);}
  192.         byteNum := succ(byteNum)
  193.       end; {DecodeByte}
  194.  
  195.     begin {DecodeLine}
  196.       lineIndex := 0;
  197.       byteNum := 3;
  198.       count := (ord(nextch) - offset);
  199.       for i := 1 to count do DecodeByte
  200.     end; {DecodeLine}
  201.  
  202.   procedure terminate;
  203.  
  204.     var trailer: string80;
  205.  
  206.     begin {terminate}
  207.       if eof(infile) then abort ('Abnormal end.');
  208.       NextLine (trailer);
  209.       if length (trailer) < 3 then abort ('Abnormal end.');
  210.       if copy (trailer, 1, 3) <> 'end' then abort ('Abnormal end.');
  211.       close (infile);
  212.       close (outfile)
  213.     end;
  214.  
  215.   begin {uudecode}
  216.     init;
  217.     NextLine(line);
  218.     while CheckLine do
  219.       begin
  220.         DecodeLine;
  221.         NextLine(line)
  222.       end;
  223.     terminate
  224.   end.
  225.